;;;
;;; contcgi.scm - ContCGI
;;;
;;;   Copyright (c) 2007 Gemma Teruaki, All rights reserved.
;;;
;;;   Redistribution and use in source and binary forms, with or without
;;;   modification, are permitted provided that the following conditions
;;;   are met:
;;;
;;;   1. Redistributions of source code must retain the above copyright
;;;      notice, this list of conditions and the following disclaimer.
;;;
;;;   2. Redistributions in binary form must reproduce the above copyright
;;;      notice, this list of conditions and the following disclaimer in the
;;;      documentation and/or other materials provided with the distribution.
;;;
;;;   3. Neither the name of the authors nor the names of its contributors
;;;      may be used to endorse or promote products derived from this
;;;      software without specific prior written permission.
;;;
;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;

(define-module www.contcgi
  (use srfi-13)
  (use gauche.parameter)
  (use text.tree)
  (use text.html-lite)
  (use www.cgi)
  (use www.fastcgi)
  (export show cont-count contcgi-main))
(select-module www.contcgi)

;;Kimura Fuyuki氏の、Gauche-fastcgi<http://d.tir.jp/pw?Gauche-fastcgi>のコードが参考になりました。
;;ありがとうございます。

;;www.fastcgiモジュールでexportされていない関数で、必要なものがいくつかあるから、取り出す。
(define fcgx-is-cgi (with-module www.fastcgi fcgx-is-cgi))
(define fcgx-accept (with-module www.fastcgi fcgx-accept))
(define fcgx-stream->port (with-module www.fastcgi fcgx-stream->port))
(define fcgx-finish (with-module www.fastcgi fcgx-finish))

;;継続サーバの肝である継続を保存するハッシュテーブル。
(define cont-table (make-hash-table 'eq?))
;;継続を保存するたびに増やすカウンタ
(define cont-count 0)
;;大域脱出用
(define return #f)
;;デバッグフラグ。showの動作が変わる。
(define debug-flag #f)

(define (error? obj) (is-a? obj <error>))

(define (error->string obj)
  (and (is-a? obj <error>) (ref obj 'message)))

(define (call-with-contcgi proc)
  (cond ((fcgx-is-cgi)
	 ;;端末からの実行の場合、debugフラグをセットする。
	 (set! debug-flag #t)
	 (proc '()))
	(else
	 ;; rush into the infinity..
	 (let loop ()
	   ;; leave these signals to libfcgi
	   (set-signal-handler! SIGTERM #t)
	   (set-signal-handler! SIGHUP #t)
	   (set-signal-handler! SIGUSR1 #t)
	   ;; mod_fastcgi requires this!
	   (set-signal-handler! SIGPIPE (lambda (k) (loop)))
	   (receive (in out err env) (fcgx-accept)
	     (let ((iport (fcgx-stream->port in))
		   (oport (fcgx-stream->port out))
		   (eport (fcgx-stream->port err))
		   (mvs (map (lambda (s)
			       (receive r (string-scan s #\= 'both) r))
			     env)))
	       (with-error-handler
		   (lambda (e)
		     (display (if (error? e) (error->string e) e) eport)
		     (newline eport)
		     (close-input-port iport)
		     (close-output-port oport)
		     (close-output-port eport)
		     (fcgx-finish)
		     (raise e))
		 (lambda ()
		   (parameterize ((cgi-metavariables mvs))
		     (write-tree (proc (cgi-parse-parameters)) oport))
		   (close-input-port iport)
		   (close-output-port oport)
		   (close-output-port eport)))))
	   (loop)))))

;;cont-tableハッシュテーブルに見つからないkeyが、CGIパラメータcont-countで指定された場合の、エラーページ
(define (error-page params)
  `(,(cgi-header)
    ,(html-doctype)
    ,(html:html
      (html:head (html:title "error"))
      (html:body
       (html:p "Error. A invalid value on the parameter 'cont-count'")
       (html:p (html:b (format "pid = ~a" (sys-getpid))))
       ;;CGIにあたえられたパラメータをhtml:tableの一覧にして表示。
       (html:table
	:border 1
	(html:tr (html:th "Name") (html:th "Value"))
	(map (lambda (p)
	       (html:tr
		(html:td (html-escape-string (car p)))
		(html:td (html-escape-string (x->string (cdr p))))))
	     params))))))

;;show は、debug時には標準出力へのwrite-treeと標準入力からのread-lineになる。
(define (show page)
  (if debug-flag
      (begin
	(write-tree page)
	(let1 query (begin
		      (display "Enter parameters (name=value).	^D to stop.\n")
		      (flush)
		      (let loop ((line (read-line))
				 (params '()))
			(if (eof-object? line)
			    (string-join (reverse params) "&")
			    (loop (read-line)
				  (if (string-null? line)
				      params
				      (cons line params))))))
	  (cgi-parse-parameters :query-string query)))
      (call/cc
       (lambda (cc)
	 ;;継続サーバの肝である継続をcont-tableに保存する
	 (hash-table-put! cont-table cont-count cc)
	 ;;保存している継続の番号をカウントする。
	 (inc! cont-count)
	 ;;ここで大域脱出returnで返したものが、CGIの出力結果になる。
	 (return page)))))

(define (contcgi-main proc)
  (call-with-contcgi
   (lambda (params)
     (call/cc
      (lambda (cc)
	;;大域脱出用にreturnをセット。
	(set! return cc)
	(let ((cont-count (cgi-get-parameter "cont-count" params :default #f :convert x->number)))
	  (if (boolean cont-count)
	      ;;foo.fcgi?cont-count=1などなら、継続を呼び出す。
	      ((hash-table-get cont-table cont-count error-page) params)
	      ;;foo.fcgiなら、メインロジックであるprocを呼び出す。
	      (proc params))))))))

(provide "www/contcgi")
